{-# LANGUAGE OverloadedStrings #-}
import Network.HTTP.Simple
import qualified Text.HTML.DOM as H
import Text.XML.Cursor
import qualified Text.XML as TX
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Encoding as TE
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import qualified Network.URI as URI
import qualified Network.HTTP.Client as URI
import qualified Codec.Text.IConv as IC
import qualified Data.HashSet as HS
import qualified Data.Graph.Inductive.Internal.Queue as Q
import Control.Exception (try)
{-import qualified Control.Concurrent as CC-}
{-import Data.Time-}
import Control.Monad
import System.IO

host :: B.ByteString
host = "www.jokeji.cn"

initReq :: Request
initReq = setRequestHost host defaultRequest

{-fps = 10-}
{-
 -dt :: NominalDiffTime
 -dt = 6000
 -}
main :: IO ()
main = do
  contentsFile <- openFile "xiaohua" AppendMode
  finishedUrl <- openFile "urls" AppendMode
  let
    bfs q mem = unless (Q.queueEmpty q) $ do
      let (n, q') = Q.queueGet q
      if HS.member n mem
          then bfs q' mem
          else do
            eResult <- crawlUrl (T.unpack n)
            case eResult of
              Left _ -> bfs q' mem
              Right (links, contents) -> do
                unless (null contents) $ T.hPutStrLn contentsFile (T.unlines contents)
                T.hPutStrLn finishedUrl n
                bfs (Q.queuePutList links q') (HS.insert n mem)
  bfs (Q.queuePut (TE.decodeUtf8 host) Q.mkQueue) HS.empty
  T.putStrLn "crawling end"
  hClose contentsFile
  hClose finishedUrl
--httpLBS 换成可重复使用manager的withManager
getDocument :: Request -> IO (Maybe Cursor)
getDocument req = do
  eres <- try (httpLBS req)
  case eres of
    Left e -> do
      print (e::HttpException)  --这个地方仅仅是为了推导e的类型,怎么写更好?不能有副作用
      return Nothing
    Right res -> return . Just . fromDocument . H.parseLBS . IC.convertFuzzy IC.Discard "GBK" "UTF-8" . getResponseBody $ res

getReq :: String -> Maybe Request
getReq uri =
  case parseRequest uri of
    Nothing -> if URI.isRelativeReference uri
                  then Just (setRequestPath (B8.pack uri) initReq)
                  else Nothing
    Just req -> if URI.host req == host
                   then Just req
                   else Nothing
-- >=> child可能更稳妥
contentRule :: Cursor -> [T.Text]
contentRule = element "span" >=> attributeIs "id" "text110" &/ elementCI "p" &// content

allLinks :: Cursor -> [T.Text]
allLinks = element "a" >=> attribute "href"

--element with case-insensitive
elementCI :: T.Text -> Axis
elementCI n = checkName (\name -> T.toLower (TX.nameLocalName name) == n)

type Links = [T.Text]
type Contents = [T.Text]
type Crawler = String -> IO (Either T.Text (Links, Contents))
crawlUrl :: Crawler
crawlUrl uri =
  case getReq uri of
    Nothing -> return $ Left "invliad url"
    Just req -> do
      mdoc <- getDocument (setRequestIgnoreStatus req)
      case mdoc of
        Nothing -> return $ Left "http exception happened"
        Just doc -> do
          let links = doc $// allLinks
              contents = doc $// contentRule
          return $ Right (links, contents)
